home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / os2 / adaptor.zip / ADAPT.ZIP / adaptor / examples / purdue / prob14.fcm < prev    next >
Encoding:
Text File  |  1993-06-26  |  4.0 KB  |  166 lines
  1.       PROGRAM PROB14
  2. C
  3. C     PROBLEM 14
  4. C
  5. C  REFERENCE:  PROBLEMS TO TEST PARALLEL AND VECTOR LANGUAGES
  6. C              CSD-TR 516, COMPUTER SCIENCE, PURDUE UNIVERSITY
  7. C              JOHN R. RICE, MAY 1, 1985
  8. C
  9. C              REVISED BY JOHN R. RICE AND J. JING, OCT. 1, 1990
  10. C
  11. C
  12. C      *************************************************
  13. C      *      Adapted for FORTRAN D benchmarking       *
  14. C      *    by  T. HAUPT  (haupt@sccs.npac.syr.edu)    *
  15. C      *                                               *
  16. C      *    Northeast Parallel Architectures Center    *
  17. C      *   at Syracuse University, Syracuse, NY, USA   *
  18. C      *************************************************
  19. C
  20. C
  21. C       VERSION SIMD/CM2-1.00
  22. C       ==================================================
  23. C
  24. c     INCLUDE '/usr/include/cm/paris-configuration-fort.h'
  25.       INTEGER KASES,JFUNK,NFUNK
  26.       PARAMETER (KASES=4)
  27.       INTEGER N(KASES)
  28. cmf$  layout N(:serial)
  29.       DATA N / 8192,16384,65536,262144/
  30.       DATA NFUNK /3/
  31.       INTEGER METH,IFUN,NK
  32.       REAL RESULT,TRUE,A,B,ERROR
  33.  
  34. C      DO  IFUN=1,NFUNK
  35. C     remember: there is corresponding ENDDO (!)
  36.       IFUN=2
  37.       CALL FVALS(A,B,TRUE,IFUN)
  38.       DO  K = 1, KASES
  39.          NK=N(K)
  40.        DO METH=1,3
  41.       CALL CM_TIMER_CLEAR(0)
  42.       CALL CM_TIMER_START(0)
  43.        DO MANY=1,50
  44.          CALL DOIT(NK,A,B,METH,IFUN,RESULT)
  45.        ENDDO
  46.       CALL CM_TIMER_STOP(0)
  47.          ERROR = RESULT - TRUE
  48.          PRINT *, ' '
  49.          PRINT *,'PROBLEM 14 WITH N = ',NK
  50.          PRINT *,'METHOD',METH,' FUNCTION ',IFUN
  51.          PRINT *,'GIVES INTEGRAL ESTIMATE =', RESULT
  52.          PRINT *,'ERROR (ESTIMATE-TRUE VALUE) = ',ERROR
  53.       CALL CM_TIMER_PRINT(0)
  54.         ENDDO
  55.        ENDDO
  56. C      ENDDO
  57. c     STOP
  58.       END
  59.  
  60.  
  61.       SUBROUTINE  DOIT(NK,A,B,METH,IFUN,RESULT)
  62.       INTEGER NK,METH,IFUN
  63.       REAL A,B,RESULT
  64.       INTEGER NSIMP,NG
  65.       REAL H77
  66.       REAL, ARRAY(:)       :: X1,X2,X3,X
  67.       REAL, ARRAY(:)       :: F1,F2,F3,F
  68.       REAL H
  69.  
  70. C
  71.       IF(METH.EQ.1) THEN
  72. C
  73. C        TRAPEZOIDAL RULE
  74. C
  75.            H = (B-A)/NK
  76.            RESULT = 0
  77.  
  78.            allocate (X(0:NK), F(0:NK))
  79.            X = A + H * [0:NK]
  80.            CALL FUN(X,NK,IFUN,F)
  81.            RESULT = (SUM(F(1:NK-1))*2.0+F(0)+F(NK))*H/2.0
  82.            deallocate (F, X)
  83.  
  84.       ENDIF
  85.  
  86.  
  87.       IF(METH.EQ.2) THEN
  88. C
  89. C        SIMPSON's METHOD
  90. C
  91.            NSIMP = NK
  92.            IF (MOD(NSIMP,2).EQ.1) NSIMP = NSIMP-1
  93.            H = (B-A)/NSIMP
  94.  
  95.  
  96.            ALLOCATE (X(0:NSIMP), F(0:NSIMP))
  97.            X = A + H * [0:NSIMP]
  98.            CALL FUN(X,NSIMP,IFUN,F)
  99.            RESULT=H*(F(0)+F(NSIMP)+4.0*SUM(F(1:NSIMP-1:2))+
  100.      *           2.0*SUM(F(2:NSIMP-2:2)))/3.0
  101.            DEALLOCATE (F, X)
  102.       ENDIF
  103.  
  104.       IF(METH.EQ.3) THEN
  105. C
  106. C        GAUSS' METHOD
  107. C
  108.             NG=(NK-MOD(NK,3))/3
  109.             H = (B-A)/NG
  110.             H77 = .774596669241*H
  111.  
  112.             allocate (X1(0:NG), X2(0:NG), X3(0:NG))
  113.             allocate (F1(0:NG), F2(0:NG), F3(0:NG))
  114.  
  115.             X1(0:NG)=A+H*[0:NG]-H/2.0-H77
  116.             X2(0:NG)=A+H*[0:NG]-H/2.0
  117.             X3(0:NG)=A+H*[0:NG]-H/2.0+H77
  118.  
  119.  
  120.            CALL FUN(X1,NG,IFUN,F1)
  121.            CALL FUN(X2,NG,IFUN,F2)
  122.            CALL FUN(X3,NG,IFUN,F3)
  123.  
  124. c          CALL FUN(A+H*[0:NG]-H/2.0-H77,NG,IFUN,F1)
  125. c          CALL FUN(A+H*[0:NG]-H/2.0,NG,IFUN,F2)
  126. c          CALL FUN(A+H*[0:NG]-H/2.0+H77,NG,IFUN,F3)
  127.  
  128.            RESULT = H*(5.0*(SUM(F1(1:NG))+SUM(F3(1:NG)))+
  129.      *             8.0*SUM(F2(1:NG)))/18.0
  130.            DEALLOCATE (F3, F2, F1, X3, X2, X1)
  131.  
  132.  
  133.       ENDIF
  134.  
  135.       END
  136.  
  137.  
  138.       SUBROUTINE FUN(X,N,IFUN,F)
  139.       INTEGER N,IFUN
  140.       REAL X(0:N),F(0:N)
  141.  
  142.       IF (IFUN.EQ.1) F = EXP(X)
  143.       IF (IFUN.EQ.2) F = SQRT(ABS(X-.2345))
  144.       IF (IFUN.EQ.3) F = 1.+X*X+1./(1.+100.*X*X)
  145.       END
  146.  
  147.       SUBROUTINE FVALS (A,B,TRUE,IFUN)
  148.       IF (IFUN.EQ.1) THEN
  149.          A = 0.
  150.          B = 1.
  151.          TRUE = 1.71828182845
  152.       ENDIF
  153.       IF (IFUN.EQ.2) THEN
  154.          A = 0.
  155.          B = 1.
  156.          TRUE = .5222099422093
  157.       ENDIF
  158.       IF (IFUN.EQ.3) THEN
  159.          A = -1.
  160.          B = 2.
  161.          TRUE = 6.29919656054
  162.       ENDIF
  163.       END
  164.  
  165.  
  166.